home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / Perl Mode / perlMode.tcl < prev    next >
Encoding:
Text File  |  1997-12-10  |  45.8 KB  |  1,588 lines  |  [TEXT/ALFA]
  1. #############################################################################
  2. # perlMode.tcl
  3. # -----------
  4. #
  5. # This is a set of routines that allow Alpha to act as a front end for the
  6. # standalone MacPerl application and that allow Perl scripts to be used as 
  7. # text filters in Alpha.  These functions are accessed through a special 
  8. # MacPerl menu.
  9. #
  10. # The features of this package are explained in the file "MacPerl Help",
  11. # accessible from the Help menu.
  12. #
  13. #############################################################################
  14. #
  15. # If you don't already have MacPerl, it's available by anonymous ftp from
  16. # the umich site
  17. #
  18. #   mac.archive.umich.edu    [141.211.165.34]    mac/development/languages
  19. #
  20. # and its mirrors.  Also, MacPerl's home site is 
  21. #
  22. #   ftp.switch.ch            [130.59.1.40]        software/mac/src/mpw_c
  23. #
  24. # MacPerl was written (ported to the Mac) by 
  25. #        Matthias Neeracher <neeri@iis.ee.ethz.ch> , and
  26. #        Tim Endres <time@ice.com>.
  27. #
  28. #############################################################################
  29. # Author: Tom Pollard <pollard@schrodinger.com>
  30. #
  31. # Contributors: Dan Herron     <herron@cogsci.ucsd.edu>
  32. #               David Schooley <schooley@ee.gatech.edu>
  33. #               Vince Darley   <darley@fas.harvard.edu>
  34. #               Martijn Koster <m.koster@nexor.co.uk>
  35. #
  36. # Version History:
  37. #
  38. # 3.12 10/97 -  Uses new menu-building code, so you can add with menu::insert (v)
  39. # 3.11 9/97  -  Fixed problem with modevars in new Alpha scheme (Johan)
  40. # 3.10 8/97  -  Modernised for new Alpha Tcl scheme (vince)
  41. # 3.0  4/97  -  MacPerl interactions don't depend on MacPerl app name anymore
  42. #               Fixed bug with perlFileAsFilter ($scriptStart uninitialized)
  43. # 2.9  3/97  -  Fixed bug in command-dbl-click help lookup for Perl5 mode
  44. # 2.8  2/97  -  Added Quick-Save commands in new submenu [Dan Herron]
  45. #               "Save As CGI" finally works.
  46. # 2.7  2/97  -  Comments before "#!/bin/perl" no longer confuse 'gotoPerlError'
  47. # 2.6  2/97  -  Added electricPerlLeft and electricPerlRight - [David Schooley]
  48. # 2.51 1/96  -  Fixed problem w/ "Tell MacPerl:Save As..."
  49. # 2.5  1/96  -  Colorization and cmd-dbl-click modified to support Perl 5 docs
  50. # 2.41 7/95  -  Minor tweaks
  51. # 2.4  7/95  -  Fixed bugs affecting running unsaved scripts and error handling
  52. # 2.3  7/95  -  Minor tweaks and code rearrangement.
  53. # 2.2  6/95  -  Text filters act only on current line if "Apply to Buffer" is
  54. #                  false and no text has been selected.
  55. #               Bug fix in error-marking for scripts sent as AppleEvent params.
  56. #               Cmd-dbl-clicking a function call jumps to function, if
  57. #                  defined in the same file.
  58. # 2.1  6/95  -  Cmd-dbl-clicking a 'require'd filename opens the file.
  59. # 2.0  6/95  -  Minor bug fixes (incl. keyword decapitalization)
  60. #               Alpha 6.0b17 compatibility updates.
  61. #               Text Filters folder is settable from the App Paths menu now.
  62. # 1.9  5/95  -  Cmd-dbl-clicking Perl keywords and special variables displays
  63. #                  the man page info.
  64. # 1.81 4/95  -  one very minor Alpha compatibility update (winInfo->getWinInfo).
  65. # 1.8  4/95  -  Menu reorganized somewhat.
  66. #               Text Filters folder can now be anywhere.
  67. #               "ApplyToBuffer" flag ignored if text has been selected.
  68. #               Bug fixes.
  69. # 1.7  1/95  -  Updated to take advantage of MacPerl 4.1.4 AppleEvent features:
  70. #                1) Text filters use 'batch' doScript (.: STDOUT file obsolete)
  71. #                2) Filter scripts sent as doScript params (.: SCRIPT file obsolete)
  72. #                3) "Save As Droplet" and "Save as Runtime" commands added.
  73. #               Errors generated in 'require'd files are now displayed correctly
  74. # 1.6 10/94  -  "UseDebugger" flag added (forces scripts to run under debugger).
  75. #               Key bindings added for some menu commands.
  76. #               "perlDoScript{,2,3}" procs consolidated into a single proc.
  77. #               "saveAndRun" option added.
  78. #               Command-line args now parsed into units more correctly, in
  79. #                   particular, quoted file names aren't broken up.
  80. #               "Close Output Window" added to "Tell MacPerl" menu.
  81. #               Updated for Alpha 5.98 to load when menu is inserted.
  82. #               The error messages window is now recycled.
  83. #               "perlRecycleOutput" recycles output window.
  84. #               Minor bug fixes.
  85. # 1.5  9/94  -  MacPerl menu rearranged somewhat.
  86. #               Explicit "Get Output Window" command added to menu.
  87. #               Reading "#!" line for args is incompatible w/ standard,
  88. #                   so it's been dropped.
  89. #               Only scan the first 40 output lines for error messages (faster)
  90. #                "wrapFilterScript" no longer opens STDIN
  91. #               Text filters may now use command-line args
  92. #               STDIN for text filters passed as explicit cmd-line arg 
  93. # 1.4  9/94  -  The "#!" line of every script is read for command-line args,
  94. #                    which are passed explicitly to MacPerl with the script.
  95. #                "PromptForArgs" menu flag added.
  96. #                "perlCmdlineArgs" modeVar holds default command-line args.
  97. #                Scripts are sent using custom "perlDoScript2" proc, which
  98. #                    allows passing of explicit command-line args.
  99. # 1.3  9/94  -  When any script generates a compilation error, the file 
  100. #                    containing the script is brought up with the offending 
  101. #                    line highlighted; all error output is also written to
  102. #                    a "Perl Error Messages" window.
  103. #                'repeatLastFilter' runs again the last text-filter script used.
  104. #                'perlLastFilter' modeVar holds pathname of last filter.
  105. #                Menu flags now mirrored as modeVars, so they can be saved and
  106. #                    restored between sessions.
  107. #                Minor bug fixes.
  108. # 1.2  8/94  -  'retrieveOutput' and 'autoSwitch' flags added.
  109. #                'openInMacperl' added.
  110. #                MacPerl output window now closed before new scripts are sent.
  111. #                Filters now abort if there are compilation errors, and
  112. #                MacPerl diagnostic output retrieved and displayed in Alpha.
  113. # 1.1  8/94  -  'quitMacperl' added.
  114. #               perl-mode file-marking updated for Alpha 5.90
  115. #               Simplified installation via 'loadMacperl'(Pete Keleher). 
  116. # 1.0  7/94  -  perl-mode setup updated for Alpha 5.85:
  117. #                    keyword colorization supported
  118. #                    custom file-marking added
  119. #               #! lines in filter scripts now handled correctly 
  120. #               Workarounds installed for AppleEvent bug in MacPerl 4.1.3
  121. # 0.9  3/94  -  perl-mode stuff added, and
  122. #               highlighted 'Perl commands' file (man page) prepared
  123. #               minor bug fixes, too
  124. # 0.8  3/94  -  flags are now check-marked
  125. # 0.7  3/94  -  nested Text Filters folder now supported
  126. #               menu format modified somewhat
  127. # 0.6  3/94  -  'applyToBuffer' flag added
  128. #               scripts in Alpha buffers can now be used as filters 
  129. # 0.5  2/94  -  'filters', 'open special' submenu added
  130. #               'overwrite' flag added
  131. # 0.2  1/94  -  menu support added (Martijn Koster <m.koster@nexor.co.uk>)
  132. #               'execute selection', 'execute buffer' commands added
  133. # 0.1  9/93  -  text filter functionality created
  134. #                  
  135. ##############################################################################
  136. #
  137. alpha::mode Perl 3.11 perlMenu {*.pl *.ph *.pm} perlMenu {
  138.     addMenu perlMenu "•132"
  139. } help {file "MacPerl Help"} uninstall {this-directory}
  140.  
  141. proc dummyPerl {} {}
  142.  
  143. #############################################################################
  144. #  Default settings for the Perl menu flags  
  145. #
  146. newPref f perluseDebugger 0 Perl shadowPerl
  147. newPref f perlretrieveOutput 1 Perl shadowPerl
  148. newPref f perlautoSwitch 1 Perl shadowPerl
  149. newPref f perloverwriteSelection 0 Perl shadowPerl
  150. newPref f perlapplyToBuffer 1 Perl shadowPerl
  151. newPref f perlpromptForArgs 0 Perl shadowPerl
  152. newPref f perlRecycleOutput 0 Perl
  153. newPref v perlPrevScript {*startup*} Perl
  154. newPref v perlCmdlineArgs {} Perl
  155. newPref v perlVersion {5} Perl shadowPerl [list 4 5]
  156.  
  157. newPref v perlFilterPath "$HOME:Tcl:Packages:Text Filters:" Perl rebuildFilterMenu
  158. newPref v perlLibFolder "" Perl buildPerlSearchPath
  159.  
  160. # Perl mode relies on the old Alpha scheme that there is both a 
  161. # PerlmodeVars(something) and a variable 'something'. This is the easiset 
  162. # way to fix this. It would be better to rewrite Perl mode to only use its
  163. # modevar array, but if I do that I will probably introduce a large number
  164. # of bugs. 
  165. # -- Johan
  166. foreach __var [list perluseDebugger perlretrieveOutput perlautoSwitch perloverwriteSelection \
  167.   perlapplyToBuffer perlpromptForArgs perlRecycleOutput perlPrevScript perlCmdlineArgs \
  168.   perlVersion perlFilterPath perlLibFolder] {
  169.     set $__var $PerlmodeVars($__var)
  170. }
  171. unset __var
  172.  
  173. #############################################################################
  174. # Other Perl-mode variable definitions
  175. #
  176. newPref f elecRBrace        {0} Perl
  177. newPref f elecLBrace        {1} Perl
  178. newPref f electricSemi    {0} Perl
  179. newPref f electricTab        {1} Perl
  180. newPref f electricReturn    {1} Perl
  181. newPref v wordBreak        {[$%@*]?\w+} Perl
  182. newPref v prefixString    {# } Perl
  183. newPref f wordWrap        {0} Perl
  184. newPref v funcExpr        {^sub *([+-a-zA-Z0-9]+)} Perl
  185. newPref v wordBreakPreface        {[^a-zA-Z0-9_%@*\$]} Perl
  186. newPref f autoMark    1    Perl
  187. newPref v stringColor    green    Perl
  188.  
  189. # ALL THE ABOVE VARS ARE NOW GLOBAL AND MODE-VARS
  190.  
  191. ##############################################################################
  192. # Miscellaneous definitions
  193. #
  194. set perlErrorWindow {* Perl Error Messages *}
  195. set perlOutputWindow {* Perl Output *}
  196. set interpPat {(#![     !-~]*)}
  197.  
  198. set perlFilterMenu "textFilters"
  199.  
  200. if {[catch "perl${perlVersion}.tcl"]} {
  201.     alertnote "Couldn't load the Perl-mode colorization file \"perl${perlVersion}.tcl\".  Contact the maintainer."
  202. }
  203.  
  204. #############################################################################
  205. #  Return paths to standard files, based on the path to MacPerl:
  206. #
  207. proc macperlFolder {} {
  208.    set name [nameFromAppl McPL]
  209.    regexp {(.*):([^:]*)} $name pathname dirname filename
  210.    return ${dirname}:
  211. }
  212.  
  213. proc stdinPath {} {
  214.    return [macperlFolder]STDIN
  215. }
  216.  
  217. proc scriptPath {} {
  218.    return [macperlFolder]SCRIPT
  219. }
  220.  
  221. #############################################################################
  222. # Define the dummy proc that will be called when the perl menu
  223. # is first inserted into the menubar
  224. #
  225. proc perlMenu {} {}
  226.  
  227. #############################################################################
  228. #  Build the perl menu
  229. #            
  230.  
  231. menu::buildProc perlMenu menu::buildPerl
  232. menu::buildProc generalOptions menu::buildgeneralOptions
  233. menu::buildProc filterOptions menu::buildfilterOptions
  234. menu::buildProc perlFilterMenu rebuildFilterMenu
  235.  
  236. proc menu::buildPerl {} {
  237.     global perlFilterMenu perlMenu perlPrevScript
  238.     set ma {
  239.         "/'<Umacperl"
  240.         {menu -m -n "tellMacperl..." -p perlTellProc {
  241.            "/O<UOpen This File"
  242.            "Save As Droplet"
  243.            "Save As Runtime"
  244.            "Save As CGI"
  245.             "(-"
  246.            "Get Output Window"
  247.            "Close Output Window"
  248.            "Quit"
  249.            }
  250.         } 
  251.         {menu -m -n "Quick Save As..." -p perlSaveProc {
  252.            "Droplet"
  253.            "Runtime"
  254.            "CGI"
  255.            }
  256.         } 
  257.         {menu -m -n help -p perlHelpProc {
  258.             "MacPerl Mode"
  259.             "Mac Specifics"
  260.             "Perl4 Manual"
  261.             "Perl5 Manual"
  262.         }}
  263.         "(-"
  264.         "runTheSelection"
  265.         "/R<UrunTheBuffer"
  266.         "/R<B<OsaveAndRun"
  267.         "runAFile"
  268.         "(-"
  269.     }
  270.     lappend ma [list menu -n $perlFilterMenu {}] \
  271.       "selectBufferAsFilter" "selectFileAsFilter"
  272.     if {$perlPrevScript == {} || $perlPrevScript == {*startup*}} {
  273.         lappend ma "/F<U(repeatLastFilter"
  274.     } else {
  275.         lappend ma "/F<UrepeatLastFilter"
  276.     }
  277.     lappend ma "(-" \
  278.       [list menu -n generalOptions {}] \
  279.       [list menu -n filterOptions {}]
  280.  
  281.     return [list build $ma -1 \
  282.       {generalOptions filterOptions perlFilterMenu} $perlMenu]
  283. }
  284.  
  285.  
  286. # General Perl-menu options menu
  287. #
  288. proc menu::buildgeneralOptions {} {
  289.     foreach i {"retrieveOutput" "autoSwitch" "promptForArgs" "useDebugger"} {
  290.         global perl$i
  291.         if [set perl$i] {
  292.             lappend ma "!•$i"
  293.         } else {
  294.             lappend ma $i
  295.         }
  296.     }
  297.     return [list build $ma]
  298. }
  299.  
  300. # Text Filter options menu
  301. #
  302. proc menu::buildfilterOptions {} {
  303.     uplevel \#0 {
  304.     menu -n filterOptions {
  305.         "applyToBuffer"
  306.         "overwriteSelection"
  307.         "(-"
  308.         "rebuildFilterMenu"
  309.     }    
  310.     markMenuItem filterOptions overwriteSelection $perloverwriteSelection
  311.     markMenuItem filterOptions applyToBuffer $perlapplyToBuffer
  312. }
  313.  
  314. }
  315.  
  316. #############################################################################
  317. #  Build a submenu of "preattached" Perl filters using the names of the 
  318. #  scripts in the Text Filters directory.  Called whenever Text Filters
  319. # folder is reassigned.
  320. #
  321. proc rebuildFilterMenu {{args}} {
  322.     global perlFilters perlFilterMenu perlFilterPath
  323.     global $perlFilterMenu
  324.     
  325.     eval [buildSubMenu [list $perlFilterPath] $perlFilterMenu textFiltersProc perlFilters]
  326. }
  327.  
  328. menu::buildSome perlMenu
  329.  
  330. # ShadowPerl sets the global vars when the mode vars are modified and
  331. # keeps the menu checkmarked correctly.
  332. #
  333. proc shadowPerl {name} {
  334.     global HOME perlMenu 
  335.     global perloverwriteSelection perlapplyToBuffer perlretrieveOutput perlautoSwitch
  336.     global perlpromptForArgs perlPrevScript perlCmdlineArgs perluseDebugger
  337.     switch $name {
  338.         "perluseDebugger"    {
  339.             markMenuItem generalOptions useDebugger $perluseDebugger
  340.          }
  341.         "perloverwriteSelection"    {
  342.             markMenuItem filterOptions overwriteSelection $perloverwriteSelection
  343.          }
  344.         "perlapplyToBuffer"    {
  345.             markMenuItem filterOptions applyToBuffer $perlapplyToBuffer
  346.          }
  347.         "perlretrieveOutput"    {
  348.             markMenuItem generalOptions retrieveOutput $perlretrieveOutput 
  349.         }
  350.         "perlautoSwitch" {    
  351.             markMenuItem generalOptions autoSwitch $perlautoSwitch 
  352.         }
  353.         "perlpromptForArgs" {    
  354.             markMenuItem generalOptions promptForArgs $perlpromptForArgs 
  355.         }
  356.         "perlVersion" {    
  357.             set modeCode "perl${perlVersion}.tcl"
  358.             if {[catch "$modeCode"]} {
  359.                 alertnote "Couldn't load the Perl-mode colorization file \"$modeCode\".  Contact the maintainer."
  360.             }
  361.         }
  362.         "perlLastFilter" {    
  363.             # Don't allow perlPrevScript to be changed from the flags menu
  364.             if {$perlPrevScript == "*startup*"} {
  365.                 set perlPrevScript $perlLastFilter
  366.                 enableMenuItem $perlMenu repeatLastFilter 1
  367.             } else {
  368.                 set perlLastFilter $perlPrevScript 
  369.             }
  370.         }
  371.     }
  372. }
  373.  
  374. #############################################################################
  375. # Menu commands
  376. #############################################################################
  377.  
  378. ############################################################################
  379. # Toggle the perl menu flags
  380. #
  381. proc retrieveOutput {} {
  382.     perlFlip perlretrieveOutput
  383. }
  384.  
  385. proc useDebugger {} {
  386.     perlFlip perluseDebugger
  387. }
  388.  
  389. proc autoSwitch {} {
  390.     perlFlip perlautoSwitch
  391. }
  392.  
  393. proc perlFlip {var} {
  394.     global $var
  395.     set $var [expr [set $var] ? 0 : 1]
  396.     synchroniseModeVar $var
  397.     shadowPerl $var
  398. }
  399.  
  400. proc overwriteSelection {} {
  401.     perlFlip perloverwriteSelection
  402. }
  403.  
  404. proc applyToBuffer {} {
  405.     perlFlip perlapplyToBuffer
  406. }
  407.  
  408. proc promptForArgs {} {
  409.     perlFlip perlpromptForArgs
  410. }
  411.  
  412. #############################################################################
  413. # Switch to MacPerl:
  414. # 
  415. proc macperl {} {
  416.     app::launchFore McPL
  417. }
  418.  
  419. #############################################################################
  420. # Interact with MacPerl in some other way besides executing a script
  421. #
  422. #DTH: note addition of two lines for auto-save
  423. proc perlTellProc {menu name} {
  424.     switch -exact $name {
  425.     "Open This File"        { openInMacperl }
  426.     
  427.     "Save As Droplet"        { saveThruMacperl "droplet" }
  428.     
  429.     "Save As Runtime"        { saveThruMacperl "runtime" }
  430.     
  431.     "Save As CGI"            { saveThruMacperl "cgi" }
  432.     
  433.     "Get Output Window"        { openPerlOutput }
  434.     
  435.     "Close Output Window"    { sendCloseWinName MacPerl $perlName ;
  436.                               sendCloseWinName MacPerl "Perl Debug" }
  437.                             
  438.     "Quit"                    { quitMacperl }
  439.     }
  440. }
  441.  
  442. proc perlSaveProc {menu name} {
  443.     switch -exact $name {
  444.     "Droplet"    { saveThruMacperl "auto-droplet" }
  445.     
  446.     "Runtime"    { saveThruMacperl "auto-runtime" }
  447.  
  448.     "CGI"        { saveThruMacperl "auto-cgi" }
  449.     }
  450. }
  451.  
  452. #############################################################################
  453. # Open the current file under MacPerl.  This used to useful for saving files 
  454. # as droplets or runtime scripts.  Maybe it's still useful for something...?
  455. #
  456. proc openInMacperl {} {
  457.     if {[winDirty]} {
  458.         case [askyesno -c "Save '[lindex [winNames] 0]'?"] in {
  459.             "yes" {save}
  460.             "no" {}
  461.             "cancel" {return}
  462.         }
  463.     }
  464.     set name [app::launchFore McPL]
  465.     sendOpenEvent -n [file tail $name] [win::Current]
  466. }
  467.  
  468. #############################################################################
  469. # Save the script in the current window as a MacPerl droplet or 
  470. # runtime script.  
  471. #
  472. proc saveThruMacperl {type} {
  473.     global ALPHA
  474.  
  475.     set name [file tail [app::launchBack McPL]]
  476.     getWinInfo arr
  477.     if {$arr(dirty) == 1} {
  478.         case [askyesno -c "Save '[lindex [winNames] 0]' source file also?"] in {
  479.             "yes" {save}
  480.             "no" {}
  481.             "cancel" {return}
  482.         }
  483.     }
  484.     #DTH note the following "if" block which replaced what is in the new "else" block
  485.     set myName [lindex [winNames -f] 0]
  486.     if {$type == "auto-droplet" || $type == "auto-runtime"} {
  487.         if {[file extension $myName] == ".pl"} {
  488.             set destfile [AEFilename [file rootname $myName]]
  489.         } else {
  490.             set destfile [AEFilename [file rootname $myName]]
  491.         }
  492.     } elseif {$type == "auto-cgi"} {
  493.         set destfile [AEFilename "[file rootname $myName].cgi"]
  494.     } else {
  495.         set destfile [AEFilename [putfile {Save droplet as} [lindex [winNames] 0]]]
  496.     }
  497.  
  498.     set script [curlyq [getText 0 [maxPos]]]
  499.     #DTH note addition of "auto-xxx" in two lines below
  500.     if {$type == "droplet" || $type == "auto-droplet"} {
  501.         set saveType "SCPT"
  502.     } elseif {$type == "runtime" || $type == "auto-runtime"} {
  503.         set saveType "MrP7"
  504.     } elseif {$type == "cgi" || $type == "auto-cgi"} {
  505.         set saveType "'WWWΩ'"
  506.     } elseif {$type == "text"} {
  507.         set saveType "TEXT"
  508.     }
  509.     
  510.     set err [catch {eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $script] {dest:} [list $destfile] {fltp:} $saveType } reply ]
  511.     if {$err} { message "AEBuild error code $err in saveThruMacperl" }
  512.     
  513. # The following lines could be used to tell MacPerl to take the script file 
  514. # from an existing disk file and then re-save it in the desired form.
  515. #
  516. #    set srcfile "\[ [AEFilename [win::Current]] \]"
  517. #    set reply [eval "AEBuild -t 36000 -r \"$name\"" core save {----} [list $srcfile] {dest:} [list $destfile] {fltp:} $saveType ]
  518. #
  519. }
  520.  
  521. #############################################################################
  522. # Quit a running MacPerl app:
  523. # 
  524. proc quitMacperl {} {
  525.     foreach proc [processes] {
  526.         set sig [lindex $proc 1]
  527.         if {$sig == "McPL"} {
  528.             sendQuitEvent [lindex $proc 0]
  529.             # switchTo is necessary to keep MacPerl from blinking
  530.             switchTo [lindex $proc 0]    
  531.         }
  532.     }
  533. }
  534.  
  535. #############################################################################
  536. # Run the selection as a MacPerl script:
  537. # (No special arrangements are made to provide input or capture the output)
  538. # 
  539. proc runTheSelection {} {
  540.     global scriptFile scriptStart
  541.     set scriptFile [win::Current]
  542.     set scriptStart [lindex [posToRowCol [getPos]] 0]
  543.     perlExecuteScript [getSelect]
  544. }
  545.  
  546. proc runTheBuffer {} {
  547.     global scriptFile scriptStart
  548.     set scriptFile [win::Current]
  549.     set scriptStart 1
  550.     perlExecuteScript [getText 0 [maxPos]]
  551. }
  552.  
  553. proc runAFile {} {
  554.     global scriptFile scriptStart
  555.     if {! [catch {getfile "Select a Perl script"} path]} {
  556.         set scriptFile $path
  557.         set scriptStart 1
  558.         perlExecuteFile $path
  559.     }
  560. }
  561.  
  562. proc saveAndRun {} {
  563.     global scriptFile scriptStart
  564.     save
  565.     set path [win::Current]   
  566.     set scriptFile $path
  567.     set scriptStart 1
  568.     perlExecuteFile $path
  569. }
  570.  
  571. #############################################################################
  572. # Run a preattached Perl text-filter script selected from the menu:
  573. #
  574. proc textFiltersProc {menu name} {
  575.     global perlFilters scriptFile scriptStart
  576.     
  577.     perlFileAsFilter $perlFilters($menu:$name)
  578. }
  579.  
  580. #############################################################################
  581. # Reuse the previous (buffer or file) filter:
  582. #
  583. proc repeatLastFilter {} {
  584.     global scriptFile scriptStart perlPrevScript perlMenu 
  585.     if {$perlPrevScript != {}} {
  586.         set stype [lindex $perlPrevScript 0]
  587.         set name [lindex $perlPrevScript 1]
  588.         if {$stype == "file"} {
  589.             perlFileAsFilter $name
  590.         } elseif {$stype == "buffer"} {
  591.             perlBufferAsFilter $name
  592.         } else {
  593.             message "Bogus filter name : \"$perlPrevScript\""
  594.             set perlPrevScript {}
  595.             synchroniseModeVar perlLastFilter $perlPrevScript
  596.             enableMenuItem $perlMenu repeatLastFilter 0
  597.         }
  598.     }
  599. }
  600.  
  601. #############################################################################
  602. # Ask for a file containing a Perl script to use as a filter:
  603. #
  604. proc selectFileAsFilter {} {
  605.     global scriptFile scriptStart perlPrevScript
  606.     if {! [catch {getfile "Select a MacPerl script"} path]} {
  607.         perlFileAsFilter $path
  608.     }
  609. }
  610.  
  611. #############################################################################
  612. # Ask for an Alpha buffer containing a Perl script to use as a filter:
  613. #
  614. proc selectBufferAsFilter {} {
  615.     global scriptFile scriptStart perlPrevScript
  616.     
  617.     set windows [winNames]
  618.     set current [lindex $windows 0]
  619.     if {[llength $windows] > 1} {
  620.         set name [listpick [lsort $windows]]
  621.         if {[string length $name]} {
  622.             # get the full name of the chosen window
  623.             set wname [lindex [winNames -f] [lsearch -exact $windows $name]]
  624.             perlBufferAsFilter $wname
  625.            }
  626.     }
  627. }
  628.  
  629. #############################################################################
  630. # Open a file from the MacPerl application folder - used by "Open Special"
  631. #
  632. proc perlOpenFile {menu name} {
  633.     set filename [macperlFolder]$name
  634.     if {[file exists $filename]} {
  635.         edit $filename
  636.     } else {
  637.         alertnote "That file doesn't exist yet"
  638.     }
  639. }
  640.  
  641. #############################################################################
  642. # Support procs
  643. #############################################################################
  644.  
  645. #############################################################################
  646. # Prompt the user to enter a string containing command-line args.
  647. #
  648. proc getCmdlineArgs {} {
  649.     global perlCmdlineArgs
  650.     if {![catch {prompt "Command-line arguments (if any):" $perlCmdlineArgs} args]} {
  651.         synchroniseModeVar perlCmdlineArgs $args
  652.     } else {
  653.         error "getCmdlineArgs: User cancelled"
  654.     }
  655.     return $args
  656. }
  657.  
  658. #############################################################################
  659. # Tell MacPerl to run a script file:
  660. #
  661. proc perlExecuteFile {path {args {}} {flags {}}} {
  662.     global ALPHA
  663.     global perlretrieveOutput perlautoSwitch perlpromptForArgs perluseDebugger
  664.     global scriptFile scriptStart filterHeadLen perlName
  665.     
  666.     if {[string length $path]} {
  667.         set perlName [file tail [app::launchBack McPL]]
  668.         if {[string length $perlName]} {
  669.                 
  670.             set ok [regexp {(.*):([^:]*)} $path pathname dirname filename]
  671.             if {!$ok} {    set name $wname    }
  672.  
  673.             if {$path != [scriptPath]} {    
  674.                 set filterHeadLen 0    
  675.             }
  676.             
  677.             if {$perluseDebugger} {
  678.                 append flags "debug"
  679.             }
  680.             if {$perlpromptForArgs} { 
  681.                 append args " [getCmdlineArgs]"
  682.             }
  683.             
  684.             sendCloseWinName $perlName $perlName
  685.             sendCloseWinName $perlName "Perl Debug"
  686.             if {$perlautoSwitch || $perluseDebugger} {
  687.                 switchTo $perlName
  688.             } else {
  689.                 message "Running file \"$filename\" as Perl script"
  690.                 watchCursor
  691.             }
  692.             
  693.             perlDoScript $perlName $path $args {} $flags
  694.             
  695. # (not sure which choice is better...)
  696. #            if {!$perlautoSwitch} {switchTo $ALPHA}
  697.             switchTo $ALPHA
  698. #
  699.             if {![getMacPerlError]} {
  700.                 if {$perlretrieveOutput} {openPerlOutput}
  701.             }
  702.         } else {
  703.             alertnote "Couldn't run MacPerl"
  704.         }
  705.     } else {
  706.         alertnote "No file specified to execute"
  707.     }
  708. }
  709.  
  710. #############################################################################
  711. # Run a MacPerl script, passed explicitly as a string:
  712. #
  713. # If no "#!/bin/perl" line already exists, one is preprended to the script
  714. # by wrapSelectScript, which also sets $filterHeadLen for use by 
  715. # getMacPerlError.
  716. # 
  717. proc perlExecuteScript {script {args ""} {flags {}} } {
  718.     global perlretrieveOutput perlautoSwitch perlpromptForArgs perlName
  719.     global scriptFile scriptStart filterHeadLen perluseDebugger ALPHA
  720.     
  721.     if {$script != ""} {
  722.         set script [wrapSelectScript $script]
  723.         
  724.         if {![regexp {(.*):([^:]*)} $scriptFile pathname dirname filename]} {
  725.             set filename $scriptFile 
  726.         }
  727.  
  728.         set perlName [file tail [app::launchBack McPL]]
  729.         if {[string length $perlName]} {
  730.         
  731.             if {$perluseDebugger} {
  732.                 append flags "debug"
  733.             }
  734.             if {$perlpromptForArgs} { 
  735.                 append args " [getCmdlineArgs]"
  736.             }
  737.             
  738.             sendCloseWinName $perlName $perlName
  739.             sendCloseWinName $perlName "Perl Debug"
  740.             if {$perlautoSwitch || $perluseDebugger} {
  741.                 switchTo $perlName
  742.             } else {
  743.                 message "Running buffer \"$filename\" as Perl script"
  744.                 watchCursor
  745.             }
  746.             
  747.             perlDoScript $perlName $script $args {} $flags
  748.             
  749.             switchTo $ALPHA
  750.  
  751.             if {![getMacPerlError]} {
  752.                 if {$perlretrieveOutput} {openPerlOutput}
  753.             }
  754.         }
  755.         
  756.     } else {
  757.             alertnote "Can't run an empty script"
  758.     }
  759. }
  760.  
  761. #############################################################################
  762. # Prepare the contents of a disk file for use as a text-filter script. 
  763. # (calls perlTextFilter to actually run the script)
  764. # 
  765. proc perlFileAsFilter {path} {
  766.     global scriptFile scriptStart perlPrevScript perlMenu 
  767.     
  768.     regexp {(.*):([^:]*)} $path pathname dirname name
  769.     
  770.     if {![catch {readFile $path} coreScript]} {
  771.         set scriptFile $path
  772.         set scriptStart 1
  773.         set script [wrapFilterScript $coreScript]
  774.         set perlPrevScript [list "file" $path]
  775.         synchroniseModeVar perlLastFilter $perlPrevScript 
  776.         enableMenuItem $perlMenu repeatLastFilter 1
  777.         message "Running file \"$name\" as text filter ..."
  778.         
  779.         perlTextFilter $script
  780.     } else {
  781.         set perlPrevScript {}
  782.         synchroniseModeVar perlLastFilter $perlPrevScript 
  783.         enableMenuItem $perlMenu repeatLastFilter 0
  784.         
  785.         alertnote "Couldn't read the script file : $path"
  786.         return
  787.     }
  788. }
  789.  
  790. #############################################################################
  791. # Prepare the contents of a text window for use as a text-filter script. 
  792. # (calls perlTextFilter to actually run the script)
  793. # 
  794. proc perlBufferAsFilter {wname} {
  795.     global scriptFile scriptStart perlPrevScript perlMenu perlName
  796.  
  797.     set ok [regexp {(.*):([^:]*)} $wname pathname dirname name]
  798.     if {!$ok} {    set name $wname    }
  799.     
  800.     if {[lsearch [winNames -f] $wname] >= 0} {
  801.         set coreScript [getText -w $wname 0 [maxPos -w $wname]]
  802.         
  803.         # Does it have any text in it?
  804.         if {[string length $coreScript]} {
  805.             set scriptFile $wname
  806.             set scriptStart 1
  807.             set script [wrapFilterScript $coreScript]
  808.             set perlPrevScript [list "buffer" $wname]
  809.             synchroniseModeVar perlLastFilter $perlPrevScript 
  810.             enableMenuItem $perlMenu repeatLastFilter 1
  811.             message "Running buffer \"$name\" as text filter ..."
  812.             
  813.             perlTextFilter $script
  814.         }
  815.     } else {
  816.         set perlPrevScript {}
  817.         synchroniseModeVar perlLastFilter $perlPrevScript 
  818.         enableMenuItem $perlMenu repeatLastFilter 0
  819.  
  820.         alertnote "Couldn't find buffer : $name"
  821.     }
  822. }
  823.  
  824. #############################################################################
  825. # Run a Perl script as a command-line text filter, arranging for a text
  826. # buffer to be attached as standard input.  The calling routine should already
  827. # have processed the script with wrapFilterScript.  This routine actually
  828. # send the script and takes care of writing the input and reading the output 
  829. # files.
  830. # 
  831. proc perlTextFilter {script {args {}} {flags {}}} {
  832.     global perloverwriteSelection perlapplyToBuffer perlpromptForArgs
  833.     global filterHeadLen scriptFile scriptStart perluseDebugger ALPHA
  834.     global perlOutputWindow perlRecycleOutput perlName
  835.  
  836.     set perlName [file tail [app::launchBack McPL]]
  837.     if {![string length $perlName]} {
  838.         alertnote "Couldn't run MacPerl"
  839.         error "Couldn't run MacPerl"
  840.     }
  841.     writeStdin
  842.  
  843.     if {$perluseDebugger} {
  844.         append flags "debug"
  845.     }
  846.     if {$perlpromptForArgs} { 
  847.         append args " [getCmdlineArgs]"
  848.     }
  849.     
  850.     sendCloseWinName $perlName $perlName
  851.     sendCloseWinName $perlName "Perl Debug"
  852.     
  853.     if {$perluseDebugger} {
  854.         switchTo $perlName
  855.         perlDoScript $perlName [scriptPath] $args [list [stdinPath]] $flags
  856.         set err [getMacPerlError]
  857.  
  858.     } else {
  859.         watchCursor
  860.         set reply [perlDoScriptBatch $perlName [scriptPath] $args [list [stdinPath]]]
  861.         set err [getBatchError $reply]
  862.     }
  863.     
  864.     switchTo $ALPHA
  865.     
  866.     if {$err == 0} {
  867.         if {$perluseDebugger} {
  868.             set outp [sendGetText $perlName $perlName]
  869.         } else {
  870. #            set outp [parseReplyOutp $reply]
  871.             set outp [parseReplyResult $reply]
  872.         }
  873.         pasteFilterResult $outp
  874.     }
  875. }
  876.  
  877.  
  878. #############################################################################
  879. # Check the MacPerl output window for error messages.
  880. #
  881. proc getMacPerlError {} {
  882.     
  883.     set diag [getPerlDiag 40]
  884.     set errf [parseDiagErrf $diag]
  885.     set srcs [parseDiagSrcs $diag]
  886.     set mesg [parseDiagMesg $diag]
  887.  
  888.     if {[string length $errf]} {
  889.         showPerlDiag $diag [string length $diag] $mesg $errf $srcs
  890.         gotoPerlError $errf $srcs $mesg
  891.         return 1
  892.         
  893.     } else {
  894.         return 0
  895.     }
  896. }
  897.  
  898. #############################################################################
  899. # Check the MacPerl batch reply for error messages.
  900. #
  901. proc getBatchError {reply} {
  902.     global perlErrorWindow
  903.     
  904.     set fatalError 0
  905.     set diag [parseReplyDiag $reply]
  906.     set errf [parseDiagErrf  $diag ]
  907.     set srcs [parseReplySrcs $reply]
  908.     set mesg [parseDiagMesg  $diag ]
  909.     set errn [parseReplyErrn $reply]
  910.  
  911.     if {$errn} {        
  912.         showPerlDiag $diag $errn $mesg $errf $srcs
  913.         gotoPerlError $errf $srcs $mesg
  914.         set fatalError 1
  915.         
  916.     } elseif {[string length $diag] > 0} {
  917.         showPerlDiag $diag $errn $mesg $errf $srcs
  918.     }
  919.     
  920.     return $fatalError
  921. }
  922.  
  923. #############################################################################
  924. # Display the Perl diagnostic output in its own window.
  925. #
  926. proc showPerlDiag {diag {errn 1} {mesg {}} {errf {}} {srcs {}}} {
  927.         global perlErrorWindow    
  928.         
  929.         set currWin [lindex [winNames] 0]
  930.         if {[lsearch [winNames] $perlErrorWindow] >= 0} {
  931.             bringToFront $perlErrorWindow
  932.             setWinInfo read-only 0
  933.             deleteText 0 [maxPos] 
  934.             insertText $diag
  935.         } else {
  936.             new -n $perlErrorWindow 
  937.              insertText $diag
  938.         }
  939.         
  940.         goto 0
  941.         catch {shrinkWindow 2}
  942.         setWinInfo dirty 0
  943.         setWinInfo read-only 1
  944.         bringToFront $currWin
  945. }
  946.  
  947. #############################################################################
  948. # Bring up a window containing the bug-ridden Perl code and highlight the
  949. # line at which the error was found.
  950. #
  951. proc gotoPerlError {errf srcs {mesg {}}} {
  952.     global scriptFile scriptStart filterHeadLen
  953.  
  954.     if {$errf == [scriptPath] || $errf == "<AppleEvent>"} {
  955.         set errf $scriptFile
  956.         # Convert it to the line number in the original file
  957.         set srcs [expr $srcs + $scriptStart - $filterHeadLen - 1]
  958.     }
  959.     # ... and leave an informative error message
  960.     #
  961.     if {[string length $mesg]} {
  962.         set mesg "$mesg at Line $srcs"            
  963.     } else {
  964.         set mesg "MacPerl flagged an error at Line $srcs"    
  965.     }
  966.     
  967.     # Bring up the script file and highlight the flagged line
  968.     #
  969.     catch {gotoFileLine $errf $srcs $mesg} fname    
  970. }
  971.  
  972. #############################################################################
  973. # Read the first block of lines (up to a maximum number) from the MacPerl
  974. # output window.
  975. #
  976. proc getPerlDiag {maxlines} {
  977.     global perlName
  978.     set pat0 {^[ \t]*$}
  979.  
  980.     set lines {}    
  981.  
  982.     # read first $maxlines of output to the MacPerl window
  983.     # (faster, but assumes error message won't appear at 
  984.     # the end of a lot of output).
  985.     #
  986.     set nlines [sendCountLines $perlName MacPerl]
  987.     set nlines [expr ($nlines > $maxlines)?$maxlines:$nlines]
  988.     if {$nlines > 0} {
  989.         set output [sendGetText $perlName $perlName 1 $nlines]
  990.         
  991.         foreach line [split $output "\r"] {
  992.             if  {[regexp $pat0 $line mtch]} {
  993.                 break
  994.             } else {
  995.                 append lines "$line\n"
  996.             }
  997.         }
  998.     }
  999.     return $lines
  1000. }
  1001.  
  1002. #############################################################################
  1003. # Extract various items out of the MacPerl diagnostic output
  1004. #
  1005.  
  1006. # Name of the file in which the error was found
  1007. #
  1008. proc parseDiagErrf {diag}    {
  1009.     if {![regexp {File '([^']+)'; Line} $diag allofit errf]} { 
  1010.         set errf {}
  1011.     }
  1012.     return $errf
  1013. }
  1014.  
  1015. # The line number on which the error was found
  1016. #
  1017. proc parseDiagSrcs {diag}    {
  1018.     if {![regexp {File '[^']+'; Line ([0-9]+)} $diag allofit srcs]} { 
  1019.         set srcs 0 
  1020.     }
  1021.     return $srcs
  1022. }
  1023.  
  1024. # The error message associated with error
  1025. #
  1026. proc parseDiagMesg {diag} {
  1027.     set pat1 {^#(.*)$}
  1028.     set pat2 {File '([^']+)'; Line ([0-9]+)}
  1029.     
  1030.     set errMessage {}
  1031.     set errFound 0
  1032.     
  1033.     foreach line [split $diag "\n"] {
  1034.         if {[regexp $pat2 $line mtch num]} {
  1035.             set errFound 1
  1036.         } elseif {[regexp $pat1 $line mtch err]} {
  1037.             if {$errFound == 0} {
  1038.                 set errMessage $err
  1039.             }
  1040.         }
  1041.     }
  1042.     return $errMessage
  1043. }
  1044.  
  1045. #############################################################################
  1046. # Extract various return parameters out of a MacPerl DoScript reply
  1047. #
  1048.  
  1049. # Result from batch script
  1050. #
  1051. proc parseReplyResult {reply} {
  1052.     if {![regexp {'?\-\-\-\-'?:“([^”]*)”} $reply allofit result]} { 
  1053.         set result {}
  1054.     }
  1055.     return $result
  1056. }
  1057.  
  1058. # Standard output of batch script
  1059. #
  1060. proc parseReplyOutp {reply} {
  1061.     if {![regexp {OUTP:“([^”]*)”} $reply allofit outp]} { 
  1062.         set outp {}
  1063.     }
  1064.     return $outp
  1065. }
  1066.  
  1067. # Diagnostic output of the batch script
  1068. #
  1069. proc parseReplyDiag {reply}    {
  1070.     if {[regexp {diag:“([^”]*)”} $reply allofit diag]}  {
  1071.     } else { 
  1072.         set diag {}
  1073.     }
  1074.     return $diag
  1075. }
  1076.  
  1077. # File alias of the script file in which the error was found
  1078. #
  1079. proc parseReplyErob {reply}    {
  1080.     if {![regexp {erob:alis\(«(.*)»\)} $reply allofit erob]} {
  1081.         set erob {} 
  1082.     }
  1083.     return $erob
  1084. }
  1085.  
  1086. # First line flagged in error
  1087. #
  1088. proc parseReplySrcs {reply}    {
  1089.     if {![regexp {erng:{srcs:([0-9]+)[^\}]*}} $reply allofit srcs]} { 
  1090.         set srcs 0 
  1091.     }
  1092.     return $srcs
  1093. }
  1094.  
  1095. # Last line flagged in error
  1096. #
  1097. proc parseReplySrce {reply}    {
  1098.     if {![regexp {erng:{[^\}]*srce:([0-9]+)}} $reply allofit srce]} { 
  1099.         set srce 0
  1100.     }
  1101.     return $srce
  1102. }
  1103.  
  1104. # Error number
  1105. #
  1106. proc parseReplyErrn {reply}    {
  1107.     if {![regexp {errn:([0-9]+)} $reply allofit errn]} {
  1108.         set errn 0
  1109.     }
  1110.     return $errn
  1111. }
  1112.  
  1113. #############################################################################
  1114. #  Take a Perl script and add commands to take the file STDIN as standard
  1115. #  input and STDOUT as standard output.  This allows scripts written as
  1116. #  Unix command-line filters to be used in the (non-MPW) Mac environment as
  1117. #  text filters.
  1118. #
  1119. #  If there's already a #! line in the script, then the new commands
  1120. #  are added after that line.  If there was no #! line in the first place,
  1121. #  one is added, in case MacPerl is set up to require it (can't hurt...) 
  1122. #
  1123. #  $filterHeadLen counts the number of lines we add to the top of the
  1124. #  original script, so that we can allow for it in interpreting error
  1125. #  messages issued by MacPerl.
  1126. #
  1127. #  *** As of MacPerl 4.1.4, this business is pretty much obsolete ***
  1128. #
  1129. proc wrapFilterScript {coreScript} {
  1130.     global scriptStart filterHeadLen interpPat
  1131.  
  1132.     if {[regexp -indices $interpPat $coreScript allofit cmdln]} {
  1133.         set endPos [lindex $cmdln 1]
  1134.         set filterHead [string range $coreScript 0 [expr $endPos+1]]
  1135.         set coreScript [string range $coreScript [expr $endPos+2] end]
  1136.         set filterHeadLen 0
  1137.         incr scriptStart [expr [llength [split $filterHead "\n\r"]] -2]
  1138.     } else {
  1139.         set filterHead "#!/bin/perl\r\n"
  1140.         set filterHeadLen 2
  1141.     }
  1142.         
  1143.     set script $filterHead
  1144.     append script $coreScript
  1145.     
  1146.     # for debugging purposes, save the script on disk
  1147.     #
  1148.     writeScript $script
  1149.     return $script
  1150. }        
  1151.  
  1152. #############################################################################
  1153. #  Add a #!/bin/perl line to the script if it doesn't contain one already.
  1154. #  (MacPerl puts up dialog if this line is missing when it expects it,
  1155. #  hanging the DoScript and leaving us stuck.)
  1156. #
  1157. proc wrapSelectScript {coreScript} {
  1158.     global scriptStart filterHeadLen interpPat
  1159.  
  1160.     if {[regexp -indices $interpPat $coreScript allofit cmdln]} {
  1161.         set endPos [lindex $cmdln 1]
  1162.         set filterHead [string range $coreScript 0 [expr $endPos+1]]
  1163.         set script $coreScript
  1164.         set filterHeadLen 0
  1165.         incr scriptStart [expr [llength [split $filterHead "\n\r"]] -2]
  1166.     } else {
  1167.         set script "#!/bin/perl\r\n"
  1168.         append script $coreScript
  1169.         set filterHeadLen 1
  1170.     }
  1171.     
  1172.     # for debugging purposes, save the script on disk
  1173.     #
  1174.     writeScript $script
  1175.     return $script
  1176. }        
  1177.  
  1178. #############################################################################
  1179. #  Paste result of the filter operation in place of the input text, or in
  1180. #  a new window (depending on the flag $perloverwriteSelection
  1181. #
  1182. proc pasteFilterResult {text} {
  1183.     global perloverwriteSelection perlRecycleOutput perlOutputWindow
  1184.     global perlapplyToBuffer 
  1185.     
  1186.     if {!$perloverwriteSelection} {
  1187.         if {$perlRecycleOutput && 
  1188.             [lsearch [winNames] $perlOutputWindow] >= 0} {                
  1189.             bringToFront $perlOutputWindow
  1190.         } else {
  1191.             new -n $perlOutputWindow
  1192.         }
  1193.     }
  1194.     
  1195.     if {$perlapplyToBuffer || $perlRecycleOutput} {
  1196.         set from 0
  1197.         set to [maxPos]
  1198.     } else {
  1199.         set from [getPos] 
  1200.         set to [selEnd]
  1201.     }    
  1202.     replaceText $from $to $text
  1203.     
  1204.     if {!$perloverwriteSelection || $perlapplyToBuffer} {
  1205.         catch {shrinkWindow 2}
  1206.         goto 0
  1207.     } else {
  1208.         catch shrinkWindow
  1209.         goto $from
  1210.     }
  1211.     if {!$perloverwriteSelection} { setWinInfo dirty 0 }
  1212. }    
  1213.  
  1214. #############################################################################
  1215. #  Extend the current selection to encompass complete lines.  If the 
  1216. #  'applyToBuffer' flag is checked, then the entire buffer is selected.
  1217. #
  1218. proc completeSelection {} {
  1219.     global perlapplyToBuffer filterInput
  1220.     set filterInput "buffer \"[lindex [winNames] 0]\""
  1221.     if {$perlapplyToBuffer} {
  1222.         set start 0
  1223.         set end [maxPos]
  1224.     } else {
  1225.         set start [lineStart [getPos]]
  1226.         set end [nextLineStart [expr [selEnd]-1]]
  1227.         if {$end == $start} { set end [nextLineStart [selEnd]] }
  1228.         
  1229.         set startLine [lindex [posToRowCol $start] 0]
  1230.         set endLine [expr [lindex [posToRowCol $end] 0] - 1]
  1231.         if {$endLine > $startLine+1} {
  1232.             set filterInput "lines $startLine to $endLine of $filterInput"
  1233.         } else {
  1234.             set filterInput "line $startLine of $filterInput"
  1235.         }
  1236.    }
  1237.     return [list $start $end]
  1238. }
  1239.  
  1240. #############################################################################
  1241. #  writeStdin: Extend the selection, as appropriate, and write it to the 
  1242. #     STDIN file in the MacPerl directory.
  1243. #
  1244. #  writeScript: Write the SCRIPT file in the MacPerl directory.  MacPerl will
  1245. #     read the script from this file. 
  1246. #
  1247. proc writeStdin {} {
  1248.     set res [completeSelection]
  1249.     set tmpfid [open [stdinPath] "w+"]
  1250.     puts $tmpfid [eval getText $res]
  1251.     close $tmpfid
  1252. }
  1253.  
  1254. # This is unnecessary now, but maybe it'll still useful to save the script
  1255. # file for debugging.
  1256. #
  1257. proc writeScript {script} {
  1258.     set tmpfid [open [scriptPath] "w+"]
  1259.     puts $tmpfid $script 
  1260.     close $tmpfid
  1261. }
  1262.  
  1263. #############################################################################
  1264. # Read the MacPerl output window and load the contents, if any, into
  1265. # a new Alpha window. 
  1266. #
  1267. proc openPerlOutput {} {
  1268.     global perlRecycleOutput perlOutputWindow perlName
  1269.     
  1270.     set output [sendGetText $perlName $perlName]
  1271.     if {[string length $output]} {
  1272.         if {$perlRecycleOutput && 
  1273.             [lsearch [winNames] $perlOutputWindow] >= 0} {
  1274.             
  1275.             bringToFront $perlOutputWindow
  1276.             replaceText 0 [maxPos] $output
  1277.         } else {
  1278.             new -n $perlOutputWindow
  1279.             insertText $output
  1280.         }
  1281.         catch {shrinkWindow 2}
  1282.         setWinInfo dirty 0
  1283.         goto 0
  1284.     }
  1285. }
  1286.  
  1287. #############################################################################
  1288. # translate special DoScript flags into flags string $usrf
  1289. #
  1290. proc perlScriptFlags {{flags {}}} {
  1291.      set usrf {}
  1292.  
  1293.     if {[lsearch -exact $flags "extract"] >= 0} {
  1294.         append usrf { "EXTR" 'true'}
  1295.     } elseif {[lsearch -exact $flags "noextract"] >= 0} {
  1296.         append usrf { "EXTR" 'fals'}
  1297.     }        
  1298.     if {[lsearch -exact $flags "debug"] >= 0} {
  1299.         append usrf { "DEBG" 'true'}
  1300.     } elseif {[lsearch -exact $flags "nodebug"] >= 0} {
  1301.         append usrf { "DEBG" 'fals'}
  1302.     }        
  1303.  
  1304.     if {[lsearch -exact $flags "local"] >= 0} {
  1305.         append usrf { "MODE" 'LOCL'}
  1306.     } elseif {[lsearch -exact $flags "batch"] >= 0} {
  1307.         append usrf { "MODE" 'BATC'}
  1308.     } elseif {[lsearch -exact $flags "remote"] >= 0} {
  1309.         append usrf { "MODE" 'RCTL'}
  1310.     }        
  1311.     return $usrf
  1312. } 
  1313.  
  1314. proc perlScriptArgs {{args {}} {fileargs {}}} {
  1315.     set nargs 0
  1316.     set argv {}
  1317.     
  1318.     foreach item [parseWords $args] {
  1319.         set item [string trim $item]
  1320.         if {[string length $item]} {
  1321.             append argv ", [curlyq $item]"
  1322.             incr nargs
  1323.         }
  1324.     }
  1325.     foreach filename $fileargs {
  1326.         set item [string trim $filename]
  1327.         if {[string length $item]} {
  1328.             append argv ", [curlyq $item]"
  1329.             incr nargs
  1330.         }
  1331.     }
  1332.     return $argv
  1333. }
  1334.  
  1335. #############################################################################
  1336. # General Apple Event routines
  1337. # (most of these have been moved to Modes:appleEvents.tcl)
  1338. #
  1339. # DoScript for MacPerl 4.1.3
  1340. # (runs in "Local" mode under v4.1.4+)
  1341. #
  1342. proc perlDoScript {appname script {args {}} {fileargs {}} {flags {}} } {
  1343.     # form list of quoted "command-line" args
  1344.     #
  1345.     if {$script != ""} {
  1346.         set argv "\[[curlyq [string trim $script]]"
  1347.         append argv [perlScriptArgs $args $fileargs]
  1348.         append argv "]"
  1349.         
  1350.         set usrf [perlScriptFlags $flags]
  1351.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc $usrf \"----\" [list $argv] "]
  1352.     #    alertnote $reply
  1353.     }
  1354. }
  1355.  
  1356. # DoScript for MacPerl 4.1.4+
  1357. #
  1358. proc perlDoScriptBatch {appname script {args {}} {fileargs {}}} {
  1359.     
  1360.     # form list of quoted "command-line" args
  1361.     #
  1362.     if {$script != ""} {
  1363.         set argv "\[[curlyq [string trim $script]]"
  1364.         append argv [perlScriptArgs $args $fileargs ] 
  1365.         append argv "]"
  1366.                 
  1367.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE BATC \"----\" [list $argv]"]
  1368.         
  1369. #         perlDisplayReply $reply
  1370.  
  1371.     } else {
  1372.         set reply {}
  1373.     }
  1374.     return $reply
  1375. }
  1376.  
  1377. # For debugging 
  1378. #
  1379. proc perlDisplayReply {reply} {
  1380.     set currWin [lindex [winNames] 0]
  1381.     new -n {*** DoScript Reply **} 
  1382.     insertText $reply
  1383.         
  1384.     goto 0
  1385.     catch {shrinkWindow 2}
  1386.     setWinInfo dirty 0
  1387.     setWinInfo read-only 1
  1388.     bringToFront $currWin
  1389. }
  1390.  
  1391. # DoScript to launch interactive debugger (for MacPerl 4.1.4+)
  1392. #
  1393. proc perlDoScriptDebug {appname script {args {}} {fileargs {}}} {
  1394.     
  1395.     # form list of quoted "command-line" args
  1396.     #
  1397.     if {$script != ""} {
  1398.         set argv "\[[curlyq [string trim $script]]"
  1399.         append argv [perlScriptArgs "$args debug" $fileargs ] 
  1400.         append argv "]"
  1401.                 
  1402.         set reply [eval "AEBuild -t 36000 -r \"$appname\" misc dosc MODE RCTL \"----\" [list $argv]"]
  1403.  
  1404.         new -n {** DoScriptDebug Reply **} 
  1405.         insertText $reply
  1406.             
  1407.         goto 0
  1408.         catch {shrinkWindow 2}
  1409.         setWinInfo dirty 0
  1410.         setWinInfo read-only 1
  1411.  
  1412.  
  1413.     } else {
  1414.         set reply {}
  1415.     }
  1416.     return $reply
  1417. }
  1418.  
  1419. ##############################################################################
  1420. # Automatic indexing of Perl subs
  1421. #
  1422. proc Perl::MarkFile {} {
  1423.     set end [maxPos]
  1424.     set pos 0
  1425.     set l {}
  1426.     while {![catch {search -f 1 -r 1 -m 0 -i 0 {^sub} $pos} res]} {
  1427.         set start [lindex $res 0]
  1428.         set end [nextLineStart $start]
  1429.         set text [lindex [getText $start $end] 1]
  1430.         set pos $end
  1431.         set inds($text) [lineStart [expr $start - 1]]
  1432.     }
  1433.  
  1434.     if {[info exists inds]} {
  1435.         foreach f [lsort [array names inds]] {
  1436.             set next [nextLineStart $inds($f)]
  1437.             setNamedMark $f $inds($f) $next $next
  1438.         }
  1439.     }
  1440. }
  1441.  
  1442.  
  1443. # Open a 'require'd Perl file.
  1444. # 
  1445. proc perlFindRequire {from {to 0}} {
  1446.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1447.     if {$to == 0} { set to $from }
  1448.     set beg [lineStart $from]
  1449.     set end [nextLineStart $to]
  1450.     set words [parseWords [getText $beg $end]]
  1451.     if {[string tolower [lindex $words 0]] != "require"} {
  1452.         error "Not a require statement"
  1453.     }
  1454.     set root [string trim [lindex $words 1] {'"}]
  1455.     return $root
  1456. }
  1457.  
  1458. proc inlineRequires {} {
  1459.     global lastMatchingLines
  1460.     
  1461.     set reqPat {^[     ]*require[     ]*(\"[^\"]+\"|\'[^\']+\'|[^     ]+)}
  1462.     set pos 0
  1463.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $reqPat $pos} mtch]} {
  1464.          [lindex [posToRowCol [lindex $mtch 0]] 0]] 
  1465.         set name [string [eval getText $mtch]
  1466.         set pos [lindex $mtch 1]
  1467.         incr matches
  1468.     }
  1469. }
  1470.  
  1471. # Open a Perl source file. 
  1472. #
  1473. proc openPerlFile {file {extensions {""}}} {
  1474.     global perlSearchPath
  1475.     # Determine absolute file specification
  1476.     # Ignore $extensions if $file already has an extension
  1477.     if {[string length [file extension $file]] == 0} {
  1478.         set extensions {""}
  1479.     }
  1480.     foreach ext $extensions {
  1481.         set filename [absolutePath $file$ext]
  1482.         if {![catch {openFileQuietly $filename}]} {
  1483.             message $filename
  1484.             return 
  1485.         }
  1486.     }
  1487.     if {[llength $perlSearchPath] == 0} { buildPerlSearchPath }
  1488.     foreach folder $perlSearchPath {
  1489.         foreach ext $extensions {
  1490.             set filename "$folder$file$ext"
  1491.             if {![catch {openFileQuietly $filename}]} {
  1492.                 message $filename
  1493.                 return     
  1494.             }
  1495.         }
  1496.     }
  1497.     beep
  1498.     message "can't find Perl source file \"$file\""
  1499. }
  1500.  
  1501. # Return a list of folders in which to search for Perl library files, 
  1502. # including the lib folder in the Perl application directory and the
  1503. # $perlLibFolder folder (if it exists) .  
  1504. # The current folder is not included in the list.
  1505. #
  1506. # (The $perlLibFolder folder is assigned from the AppPaths submenu.)
  1507. #
  1508. proc buildPerlSearchPath {} {
  1509.     global perlLibFolder perlSearchPath
  1510.     message "building Perl search path..."
  1511.     set folders {}
  1512.     
  1513.     # The local lib folder:
  1514.     if {[info exists perlLibFolder] && [string length $perlLibFolder] > 0} { 
  1515.         set folders [concat $folders [list $perlLibFolder]]
  1516.         # Search subfolders one level deep:
  1517.         set folders [concat $folders [listSubfolders $perlLibFolder 1]]
  1518.     }
  1519.  
  1520.     # Any "*lib*" folders in the MacPerl application folder:
  1521.     set macperlPath [nameFromAppl McPL]
  1522.     set appDir [file dirname $macperlPath]
  1523.     set folders [concat $folders [list $appDir]]
  1524.     # Bug:  'glob' is case sensitive!
  1525.     foreach folder [glob "$appDir:*\[Ll\]ib*"] {
  1526.         set folders [concat $folders [list $folder]]
  1527.         # Search subfolders one level deep:
  1528.         set folders [concat $folders [listSubfolders $folder 1]]
  1529.     }
  1530.  
  1531.     # Make sure each folder ends with a colon
  1532.     set perlSearchPath {}
  1533.     foreach folder $folders {
  1534.         set folder "[string trimright $folder {:}]:"
  1535.         set perlSearchPath [concat $perlSearchPath [list $folder]]
  1536.     }
  1537. }
  1538.  
  1539. ###########################################################################
  1540. #
  1541. proc perlHelpProc {menu item} {
  1542.     global HOME
  1543.     switch $item {
  1544.         "MacPerl Mode"    {
  1545.                 if {[catch {openFileQuietly "$HOME:Help:MacPerl Help"}]} {
  1546.                     alertnote "File not found:\r$HOME:Help:MacPerl Help"
  1547.                 }
  1548.             }
  1549.         "Mac Specifics"    {
  1550.                 if {[catch {openFileQuietly "$HOME:Help:MacPerl.Specifics"}]} {
  1551.                     alertnote "File not found:\r$HOME:Help:MacPerl.Specifics"
  1552.                 }
  1553.             }
  1554.         "Perl4 Manual"    {
  1555.                 if {[catch {openFileQuietly "$HOME:Help:Perl Commands"}]} {
  1556.                     alertnote "File not found:\r$HOME:Help:Perl Commands"
  1557.                 }
  1558.             }
  1559.         "Perl5 Manual"    {
  1560.                 catch {editMark "$HOME:Help:Perl Commands" Perl5 -r}
  1561.             }
  1562.     }
  1563. }
  1564.  
  1565. proc Perl::electricLeft {} {
  1566.     set prevChar [lookAt [expr [getPos] - 1]]
  1567.     if {$prevChar == " " || $prevChar == "\)"} {
  1568.         # Trick to continue with the generic function.
  1569.         error "Use generic function!"
  1570.     }
  1571.     deleteText [getPos] [selEnd]
  1572.     insertText "\{"
  1573. }
  1574.  
  1575. proc Perl::electricRight {} {
  1576.     set prevChar [lookAt [expr [getPos] - 1]]
  1577.     if {$prevChar == " " || $prevChar == ";" || $prevChar == "\t" || $prevChar == "\}"} {
  1578.         # Trick to continue with the generic function.
  1579.         error "Use generic function!"
  1580.     }
  1581.     deleteText [getPos] [selEnd]
  1582.     insertText "\}"
  1583.     catch {blink [matchIt "\}" [expr [getPos]-2]]}
  1584.     return
  1585. }
  1586.  
  1587.  
  1588.